Hands vs. faces in manual annotations, broken down by child vs. adult hands
face_vs_hands_goldset <- d %>%
full_join(child_adult_hand_annotations, by=c("vid_name", "frame")) %>%
mutate(frame_id = paste0(vid_name, '-', frame)) %>%
replace_na(list(adult_hand_seg = FALSE, child_hand_seg = FALSE)) %>% ## replace NAs from segmentation with false for hands since all we got annotations for all frames with hands
group_by(child_id, age_day_bin) %>%
summarize(num_detect = length(unique(frame_id)), prop_faces = sum(face_present_ketan) / num_detect, prop_hands = sum(hand_present_ketan) / num_detect, prop_adult_hands = sum(adult_hand_seg) / num_detect, prop_child_hands = sum(child_hand_seg) / num_detect) %>%
filter(num_detect > 50) %>% ## need at least x samples per point
mutate(faces_vs_hands = prop_faces - prop_hands, faces_vs_adult_hands = prop_faces - prop_adult_hands, faces_vs_child_hands = prop_faces - prop_child_hands)
## Warning: Column `vid_name` joining character vector and factor, coercing
## into character vector
## Warning: Grouping rowwise data frame strips rowwise nature
## Warning: Factor `child_id` contains implicit NA, consider using
## `forcats::fct_explicit_na`
## Warning: Factor `child_id` contains implicit NA, consider using
## `forcats::fct_explicit_na`
Faces, Adult Hands, Child Hands x Age/Child
a_hands = ggplot(face_vs_hands_goldset, aes(x=age_day_bin, y=prop_adult_hands, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth(span=10) +
ylab("Prop adult hands") +
xlab("Age (weeks)") +
ylim(0,1) +
theme(legend.position = "none")
c_hands = ggplot(face_vs_hands_goldset, aes(x=age_day_bin, y=prop_child_hands, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth(span=10) +
ylab("Prop child hands") +
xlab("Age (weeks)") +
ylim(0,1) +
theme(legend.position = "none")
faces = ggplot(face_vs_hands_goldset, aes(x=age_day_bin, y=prop_faces, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth(span=10) +
ylab("Prop faces") +
xlab("Age (weeks)")
ylim(0,1)
## <ScaleContinuousPosition>
## Range:
## Limits: 0 -- 1
ggarrange(a_hands, c_hands, faces, nrow=1)
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
## Warning: Removed 1 rows containing non-finite values (stat_smooth).
## Warning: Removed 1 rows containing missing values (geom_point).
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
## Warning: Removed 1 rows containing non-finite values (stat_smooth).
## Warning: Removed 1 rows containing missing values (geom_point).
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
## Warning: Removed 1 rows containing non-finite values (stat_smooth).
## Warning: Removed 1 rows containing missing values (geom_point).

Faces vs Hands (all), Faces vs Adult Hands
faces_vs_adult_hands = ggplot(face_vs_hands_goldset, aes(x=age_day_bin, y=faces_vs_adult_hands, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth(span=10) +
ylab(" faces - adult hands") +
ylim(-.5,.5)
faces_vs_all_hands = ggplot(face_vs_hands_goldset, aes(x=age_day_bin, y=prop_faces - prop_hands, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth(span=10) +
ylab(" faces - all hands") +
ylim(-.5,.5)
ggarrange(faces_vs_adult_hands, faces_vs_all_hands, nrow=1)
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
## Warning: Removed 1 rows containing non-finite values (stat_smooth).
## Warning: Removed 1 rows containing missing values (geom_point).
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'
## Warning: Removed 4 rows containing non-finite values (stat_smooth).
## Warning: Removed 4 rows containing missing values (geom_point).

Look at any variance by location from single-location videos
faces_by_location <- d %>%
filter(!is.na(Location)) %>%
filter(count_locations==1) %>%
group_by(Location, child_id) %>%
multi_boot_standard(col="face_present_ketan") %>%
ungroup %>%
mutate(Location = fct_reorder(Location, mean))
## Warning: Grouping rowwise data frame strips rowwise nature
hands_by_location <- d %>%
filter(!is.na(Location)) %>%
filter(count_locations==1) %>%
group_by(Location, child_id) %>%
multi_boot_standard(col="hand_present_ketan") %>%
ungroup %>%
mutate(Location = fct_reorder(Location, mean))
## Warning: Grouping rowwise data frame strips rowwise nature
(plot_faces_loc = ggplot(faces_by_location, aes(x = Location, y = mean, col=child_id)) +
geom_pointrange(aes(ymin = ci_lower, ymax = ci_upper)) +
ylim(0,.8) +
coord_flip() +
ylab('Proportion Faces'))
## Warning: Removed 1 rows containing missing values (geom_pointrange).

(plot_hand_loc = ggplot(hands_by_location, aes(x = Location, y = mean, col=child_id)) +
geom_pointrange(aes(ymin = ci_lower, ymax = ci_upper)) +
coord_flip() +
ylim(0,.8) +
ylab('Proportion Hands'))
## Warning: Removed 1 rows containing missing values (geom_pointrange).

# ggarrange(plot_faces_loc, plot_hand_loc)
Analyze basics from bounding boxes on goldset
Preprocess bb data
bb <- bb %>%
mutate(age_day_bin = cut(age_days, bins, labels=round(bin_starts/30,1))) %>%
mutate(age_day_bin = as.numeric(as.character(age_day_bin))) %>%
mutate(x_pos = left*width_px, y_pos = top*height_px) %>%
mutate(center_x = x_pos + width_x/2, center_y = y_pos - height_y/2) %>%
filter(!is.na(child_id))
bb_forheatmap <- bb %>%
filter(height>0)
Number of people, face/hand area, position descriptives
##
num_people_goldset <- bb %>%
group_by(child_id, age_day_bin) %>%
summarize(num_people = mean(num_faces), num_detect = length(num_faces))
## Warning: Grouping rowwise data frame strips rowwise nature
face_area_goldset <- bb %>%
filter(mean_conf > 0) %>%
filter(face_openpose==1) %>%
group_by(child_id, age_day_bin) %>%
summarize(face_area = mean(area), num_detect = length(area))
## Warning: Grouping rowwise data frame strips rowwise nature
hand_area_goldset <- bb %>%
filter(mean_conf > 0) %>%
filter(hand_openpose==1) %>%
group_by(child_id, age_day_bin) %>%
summarize(hand_area = mean(area), num_detect = length(area))
## Warning: Grouping rowwise data frame strips rowwise nature
pos_goldset <- bb %>%
filter(mean_conf > 0) %>%
group_by(child_id, age_day_bin, label) %>%
summarize(x_center = mean(center_x), num_detect = length(center_x))
## Warning: Grouping rowwise data frame strips rowwise nature
top_pos_goldset <- bb %>%
filter(mean_conf > 0) %>%
group_by(child_id, age_day_bin, label) %>%
summarize(y_center = mean(center_y), num_detect = length(center_y))
## Warning: Grouping rowwise data frame strips rowwise nature
## number of people
num_people_goldset$age_day_bin = as.numeric(num_people_goldset$age_day_bin)
ggplot(num_people_goldset, aes(x=age_day_bin, y=num_people, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth() +
ylab("# people")
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## face size
face_area_goldset$age_day_bin = as.numeric(face_area_goldset$age_day_bin)
ggplot(face_area_goldset, aes(x=age_day_bin, y=face_area, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth() +
ylab("face size")
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## hand size
hand_area_goldset$age_day_bin = as.numeric(hand_area_goldset$age_day_bin)
ggplot(hand_area_goldset, aes(x=age_day_bin, y=hand_area, col=child_id, size=num_detect)) +
geom_point(alpha=.5) +
geom_smooth() +
ylab("hand size")
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

## y position
top_pos_goldset$age_day_bin = as.numeric(top_pos_goldset$age_day_bin)
ggplot(top_pos_goldset, aes(x=age_day_bin, y=y_center, col=label)) +
geom_point(alpha=.5) +
geom_smooth() +
ylab("detection_position_y")
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

Code ot render out bounding boxes from OP on sample frames
# g_seg_info <- g_seg %>%
# distinct(full_image_path, vid_name_short, frame_ind)
#
# bb_check <- bb %>%
# mutate(frame_ind = frame, vid_name_short = vid_name) %>%
# left_join(g_seg_info, by=c("vid_name_short","frame_ind")) %>%
# filter(!is.na(full_image_path)) %>%
# filter(mean_conf > 0)
# # dir.create(paste0('bbcheck/'))
# unique_images <- bb_check$full_image_path[101:200]
#
# for (image in unique_images){
# this_image_rgb <- image_read(image)
# img <- image_draw(this_image_rgb)
# a <- bb_check %>%
# filter(full_image_path %in% image)
#
# # rect(a$x_pos, a$y_pos-a$height_y, a$x_pos+a$width_x, a$y_pos)
# text(a$center_x, a$center_y, a$center_y)
#
# annotated_file = paste0('bbcheck/',unique(a$vid_name_short), unique(a$frame_ind), 'OP-center.jpg')
# image_write(img, annotated_file)
# dev.off()
# }
Heatmaps of face detection positions across age groups
face_heatmap_young <- bb_forheatmap %>%
filter(label=='face') %>%
filter(age_day_bin<12)
face_heatmap_middle<- bb_forheatmap %>%
filter(label=='face') %>%
filter(age_day_bin>12 & age_day_bin<18.1)
face_heatmap_oldest <- bb_forheatmap %>%
filter(label=='face') %>%
filter(age_day_bin>18.1)
(p1_youngest <- ggplot(face_heatmap_young, aes(x=center_x, y=center_y)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Faces: 6-12m') +
ylim(0,height_px) +
scale_y_reverse())
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

(p2_middle <- ggplot(face_heatmap_middle, aes(x=center_x, y=center_y)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Faces: 12-18m') +
ylim(0,height_px) +
scale_y_reverse())
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

(p3_oldest <- ggplot(face_heatmap_oldest, aes(x=x_pos, y=y_pos)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Faces: 18m +') +
ylim(0,height_px) +
scale_y_reverse())
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

# ggarrange(p1_youngest, p2_middle,p3_oldest, nrow=1)
Heatmaps of hand detection positions across age groups
hand_heatmap_young <- bb_forheatmap %>%
filter(label=='hand') %>%
filter(age_day_bin<12)
hand_heatmap_middle<- bb_forheatmap %>%
filter(label=='hand') %>%
filter(age_day_bin>12 & age_day_bin<18.1)
hand_heatmap_oldest <- bb_forheatmap %>%
filter(label=='hand') %>%
filter(age_day_bin>18.1)
(p1_youngest <- ggplot(hand_heatmap_young, aes(x=center_x, y=center_y)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Hands: 6-12m') +
ylim(0,height_px) +
scale_y_reverse())
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

(p2_middle <- ggplot(hand_heatmap_middle, aes(x=center_x, y=center_y)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Hands: 12-18m') +
ylim(0,height_px) +
scale_y_reverse())
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

(p3_oldest <- ggplot(hand_heatmap_oldest, aes(x=x_pos, y=y_pos)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Hands: 18m +') +
ylim(0,height_px) +
scale_y_reverse())
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

# ggarrange(p1_youngest, p2_middle,p3_oldest, nrow=1)
CHild vs adult hand heatmaps from mturk sample
child_hands <- g_seg %>%
filter(label=="Child hand")
adult_hands <- g_seg %>%
filter(label=="Adult hand")
##
ggplot(child_hands, aes(x=left, y=top)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ggtitle('Child hands (mturk)') +
ylim(0,height_px) +
scale_y_reverse()
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.

##
ggplot(adult_hands, aes(x=left, y=top)) +
geom_point() +
stat_density_2d(aes(fill = ..level..), geom="polygon") +
coord_fixed(ratio=1) +
ylim(0,height_px) +
scale_y_reverse() +
ggtitle('Adult hands (mturk)')
## Scale for 'y' is already present. Adding another scale for 'y', which
## will replace the existing scale.
